perm filename TICTA2.LSP[206,JMC] blob
sn#073067 filedate 1973-11-18 generic text, type T, neo UTF8
00100
00200
00300 (DEFPROP TICTACFNS
00400 (TRY2 COMMENCE
00500 NEWGAME
00600 TER
00700 IMVAL
00800 SUCCESSORS
00900 REVERT
01000 UPDATE
01100 PTS
01200 LINES
01300 SORT
01400 SORTA
01500 SORTB
01600 SORTC
01700 WIN
01800 ANSWER
01900 DOUBLETH
02000 TWOLIS
02100 THREAT)
02200 VALUE)
02300
02400 (DEFPROP COMMENCE
02500 (LAMBDA NIL
02600 (PROG NIL
02700 (ARRAY LINES T 12)
02800 (ARRAY XCOUNT 44 11)
02900 (ARRAY OCOUNT 44 11)
03000 (STORE (LINES 1) (QUOTE (1 4 7)))
03100 (STORE (LINES 2) (QUOTE (1 5)))
03200 (STORE (LINES 3) (QUOTE (1 6 10)))
03300 (STORE (LINES 4) (QUOTE (2 4)))
03400 (STORE (LINES 5) (QUOTE (2 5 7 10)))
03500 (STORE (LINES 6) (QUOTE (2 6)))
03600 (STORE (LINES 7) (QUOTE (3 4 10)))
03700 (STORE (LINES 10) (QUOTE (3 5)))
03800 (STORE (LINES 11) (QUOTE (3 6 7)))))
03900 EXPR)
04000
04100 (DEFPROP NEWGAME
04200 (LAMBDA NIL
04300 (PROG (N)
04400 (SETQ N 0)
04500 L (SETQ N (ADD1 N))
04600 (STORE (XCOUNT N) 0)
04700 (STORE (OCOUNT N) 0)
04800 (COND ((LESSP N 10) (GO L)))
04900 (SETQ P1 NIL)
05000 (SETQ XS NIL)
05100 (SETQ OS NIL)
05200 (SETQ BS (QUOTE (1 2 3 4 5 6 7 10 11)))
05300 (SETQ W NIL)
05400 (SETQ LEVEL 0)
05500 (SETQ COUNT 0)
05600 (RETURN (QUOTE (NEW GAME)))))
05700 EXPR)
05800
05900 (DEFPROP TER
06000 (LAMBDA(P ALPHA BETA)
06100 (AND (NOT (NULL P))
06200 (OR (EQUAL LEVEL 11)
06300 (LESSP (DIFFERENCE 11 LEVEL) (CAR ALPHA))
06400 (GREATERP (PLUS -11 LEVEL) (CAR BETA))
06500 (PROG (N)
06600 (SETQ N 0)
06700 L2 (SETQ N (ADD1 N))
06800 (COND ((EQUAL 3 (COND (W (XCOUNT N)) (T (OCOUNT N)))) (RETURN T)))
06900 (COND ((LESSP N 10) (GO L2)))
07000 (RETURN NIL)))))
07100 EXPR)
07200
07300 (DEFPROP IMVAL
07400 (LAMBDA(P ALPHA BETA)
07500 (COND (W
07600 (PROG (N)
07700 (SETQ N 0)
07800 L3 (SETQ N (ADD1 N))
07900 (COND ((EQUAL 3 (XCOUNT N)) (RETURN (DIFFERENCE 12 LEVEL))))
08000 (COND ((LESSP N 10) (GO L3)) (T (RETURN 0)))))
08100 (T
08200 (PROG (N)
08300 (SETQ N 0)
08400 L4 (SETQ N (ADD1 N))
08500 (COND ((EQUAL 3 (OCOUNT N)) (RETURN (PLUS -12 LEVEL))))
08600 (COND ((LESSP N 10) (GO L4)) (T (RETURN 0)))))))
08700 EXPR)
08800
08900 (DEFPROP SUCCESSORS
09000 (LAMBDA (P ALPHA BETA) (SORT (MAPCAR (FUNCTION (LAMBDA (X) (CONS X P))) BS)))
09100 EXPR)
09200
09300 (DEFPROP REVERT
09400 (LAMBDA NIL
09500 (PROG (A)
09600 (SETQ LEVEL (SUB1 LEVEL))
09700 (SETQ BS (CONS (CAR (COND (W XS) (T OS))) BS))
09800 (COND (W (SETQ XS (CDR XS))) (T (SETQ OS (CDR OS))))
09900 (SETQ A (LINES (CAR P1)))
10000 L5 (COND ((NULL A) (GO L6)))
10100 (COND (W (STORE (XCOUNT (CAR A)) (SUB1 (XCOUNT (CAR A)))))
10200 (T (STORE (OCOUNT (CAR A)) (SUB1 (OCOUNT (CAR A))))))
10300 (SETQ A (CDR A))
10400 (GO L5)
10500 L6 (SETQ W (NOT W))
10600 (SETQ P1 (CDR P1))
10700 (RETURN)))
10800 EXPR)
10900
11000 (DEFPROP UPDATE
11100 (LAMBDA(M)
11200 (PROG (A)
11300 (SETQ LEVEL (ADD1 LEVEL))
11400 (COND (W (SETQ OS (CONS M OS))) (T (SETQ XS (CONS M XS))))
11500 (SETQ BS (DELETE M BS))
11600 (SETQ P1 (CONS M P1))
11700 (SETQ COUNT (ADD1 COUNT))
11800 (SETQ A (LINES M))
11900 L7 (COND ((NULL A) (GO L8)))
12000 (COND (W (STORE (OCOUNT (CAR A)) (ADD1 (OCOUNT (CAR A)))))
12100 (T (STORE (XCOUNT (CAR A)) (ADD1 (XCOUNT (CAR A))))))
12200 (SETQ A (CDR A))
12300 (GO L7)
12400 L8 (SETQ W (NOT W))
12500 (RETURN )))
12600 EXPR)
12700
12800 (DEFPROP SORT
12900 (LAMBDA (U) (SORTA U NIL NIL))
13000 EXPR)
13100
13200 (DEFPROP SORTA
13300 (LAMBDA(U TH ORD)
13400 (COND ((NULL U) (APPEND TH ORD))
13500 ((WIN (CAR U)) (LIST (CAR U)))
13600 ((ANSWER (CAR U)) (SORTB (CDR U) (CAR U)))
13700 ((DOUBLETH (CAR U)) (SORTC (CDR U) (CAR U)))
13800 ((THREAT (CAR U)) (SORTA (CDR U) (CONS (CAR U) TH) ORD))
13900 (T (SORTA (CDR U) TH (CONS (CAR U) ORD)))))
14000 EXPR)
14100
14200 (DEFPROP SORTB
14300 (LAMBDA (U M) (COND ((NULL U) (LIST M)) ((WIN (CAR U)) (LIST (CAR U))) (T (SORTB (CDR U) M))))
14400 EXPR)
14500
14600 (DEFPROP SORTC
14700 (LAMBDA(U M)
14800 (COND ((NULL U) (LIST M))
14900 ((WIN (CAR U)) (LIST (CAR U)))
15000 ((ANSWER (CAR U)) (SORTB (CDR U) (CAR U)))
15100 (T (SORTC (CDR U) M))))
15200 EXPR)
15300
15400 (DEFPROP WIN
15500 (LAMBDA(P)
15600 (COND (W (ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (OCOUNT X)))) (LINES (CAR P))))
15700 (T (ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (XCOUNT X)))) (LINES (CAR P))))))
15800 EXPR)
15900
16000 (DEFPROP ANSWER
16100 (LAMBDA(P)
16200 (COND (W (ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (XCOUNT X)))) (LINES (CAR P))))
16300 (T (ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (OCOUNT X)))) (LINES (CAR P))))))
16400 EXPR)
16500
16600 (DEFPROP DOUBLETH
16700 (LAMBDA(P)
16800 (TWOLIS (FUNCTION
16900 (LAMBDA(X)
17000 (AND (EQUAL 1 (COND (W (OCOUNT X)) (T (XCOUNT X))))
17100 (ORLIS (FUNCTION (LAMBDA (W) (MEMBER X (LINES W)))) (DELETE (CAR P) BS)))))
17200 (LINES (CAR P))))
17300 EXPR)
17400
17500 (DEFPROP THREAT
17600 (LAMBDA(P)
17700 (ORLIS (FUNCTION
17800 (LAMBDA(X)
17900 (AND (EQUAL 1 (COND (W (OCOUNT X)) (T (XCOUNT X))))
18000 (ORLIS (FUNCTION (LAMBDA (W) (MEMBER X (LINES W)))) (DELETE (CAR P) BS)))))
18100 (LINES (CAR P))))
18200 EXPR)
18300
18400 (DE TWOLIS (PRED U) (AND (NOT (NULL U))
18500 (OR (AND (PRED (CAR U)) (ORLIS PRED (CDR U)))
18600 (TWOLIS PRED (CDR U)))))